home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 February: Tool Chest / Apple Developer CD Series Tool Chest February 1996 (Apple Computer)(1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / zebu v3.3.3 (LALR parser) / zebu-oset.lisp < prev    next >
Encoding:
Text File  |  1994-09-12  |  12.7 KB  |  370 lines  |  [TEXT/ttxt]
  1. ; -*- mode:     CL -*- ----------------------------------------------------- ;
  2. ; File:         zebu-oset.lisp
  3. ; Description:  Conversion to CL of the original Scheme program by (W M Wells)
  4. ; Author:       Joachim H. Laubsch
  5. ; Created:      14-Nov-90
  6. ; Modified:     Tue Aug  2 15:03:39 1994 (Joachim H. Laubsch)
  7. ; Language:     CL
  8. ; Package:      ZEBU
  9. ; Status:       Experimental (Do Not Distribute) 
  10. ; RCS $Header: $
  11. ;
  12. ; (c) Copyright 1990, Hewlett-Packard Company
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ; Revisions:
  15. ; RCS $Log: $
  16. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  17. ;;;             Copyright (C) 1989, by William M. Wells III
  18. ;;;                         All Rights Reserved
  19. ;;;     Permission is granted for unrestricted non-commercial use.
  20.  
  21. (in-package "ZEBU")
  22.  
  23. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  24. ;;                                Ordered Sets
  25. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  26.  
  27. ;;; A simple ordered set facility.  Items kept in these sets must
  28. ;;; have an order function: these are supplied for integers and
  29. ;;; osets themselves.  Items are kept in sorted lists, smallest
  30. ;;; first.  Could be re-done with binary search trees.
  31. ;;; See integer-order-function for how order functions are supposed to
  32. ;;; work.
  33.  
  34. ;;; Constructor will default to make a set that orders integers.
  35.  
  36. (defstruct (oset (:copier nil)
  37.          )
  38.   (item-list     '() :type list)
  39.   (order-fn      #'integer-order-function)
  40.   (cardinality   0   :type fixnum))
  41.  
  42. (declaim (inline oset-empty?))
  43. (defun oset-empty? (oset) (null (oset-item-list oset)))
  44.  
  45. ;;; Example of how the order function is supposed to work.
  46.  
  47. (declaim (inline integer-order-function))
  48. (defun integer-order-function (a b)
  49.   (declare (fixnum a b))
  50.   (cond ((< a b) 'correct-order)
  51.     ((> a b) 'wrong-order)
  52.     (T 'equal)))
  53.  
  54. ;;; Destructively insert an item into a set
  55. ;;; Returns the item if it wasn't there already, else NIL.
  56. (defun oset-insert! (item set)
  57.   ;; Returns  NIL if nothing is inserted or T if item was inserted
  58.   ;; otherwise like oset-insert-2!
  59.   (declare (type oset set))
  60.   (let ((ilist (oset-item-list set)))
  61.     (if (null ilist)
  62.     (progn (setf (oset-item-list set) (list item)
  63.              (oset-cardinality set) 1)
  64.            t)
  65.       (let ((odf (oset-order-fn set))
  66.         order)
  67.     (cond ((eq 'correct-order
  68.            (setq order (funcall odf item (car (the cons ilist)))))
  69.            (setf (oset-item-list set) (cons item ilist))
  70.            (incf (oset-cardinality set))
  71.            t)
  72.           ((eq 'equal order) nil)    ; item already there
  73.           (T ;; Ilist isn't null, and item goes somewhere after
  74.              ;; the car of ilist.
  75.            (do ((ilist ilist ilist-cdr)
  76.             (ilist-cdr (cdr ilist) (cdr ilist-cdr)))
  77.            ((null ilist-cdr)
  78.             (setf (cdr (the cons ilist)) (list item))
  79.             (incf (oset-cardinality set))
  80.             t)
  81.          (let ((ilist-cdr1 (car (the cons ilist-cdr))))
  82.            (when (eq 'correct-order
  83.                  (setq order (funcall odf item ilist-cdr1)))
  84.              (setf (cdr (the cons ilist)) (cons item ilist-cdr))
  85.              (incf (oset-cardinality set))
  86.              (return-from oset-insert! t))
  87.            (when (eq 'equal order) ; already there
  88.              (return-from oset-insert! nil))))))))))
  89.  
  90. ;;; Returns two values: (1) NIL if nothing is inserted ot T if item was
  91. ;;; inserted, and (2) a pointer to the item either found or inserted
  92. ;;; into the set (so is eq to a member of the set).
  93.  
  94. (defun oset-insert-2! (item set)
  95.   (declare (type oset set))
  96.   (let ((ilist (oset-item-list set)))
  97.     (if (null ilist)
  98.     (progn (setf (oset-item-list set) (list item)
  99.              (oset-cardinality set) 1)
  100.            (values t item))
  101.       (let ((odf (oset-order-fn set))
  102.         (ilist-hd (car (the cons ilist)))
  103.         order)
  104.     (cond ((eq 'correct-order
  105.            (setq order (funcall odf item ilist-hd)))
  106.            (setf (oset-item-list set) (cons item ilist))
  107.            (incf (oset-cardinality set))
  108.            (values t item))
  109.           ((eq 'equal order) (values nil ilist-hd))
  110.           ;; item already there
  111.           (T ;; Ilist isn't null, and item goes somewhere after
  112.              ;; the car of ilist.
  113.            (do ((ilist ilist ilist-cdr) (ilist-cdr (cdr ilist) (cdr ilist-cdr)))
  114.            ((null ilist-cdr)
  115.             (setf (cdr (the cons ilist)) (list item))
  116.             (incf (oset-cardinality set))
  117.             (values t item))
  118.          (let ((ilist-cdr1 (car (the cons ilist-cdr))))
  119.            (when (eq 'correct-order
  120.                  (setq order (funcall odf item ilist-cdr1)))
  121.              (setf (cdr (the cons ilist)) (cons item ilist-cdr))
  122.              (incf (oset-cardinality set))
  123.              (return-from oset-insert-2! (values t item)))
  124.            (when (eq 'equal order) ; already there
  125.              (return-from oset-insert-2! (values nil ilist-cdr1)))))))))))
  126.  
  127.  
  128. ;;; Insert a list of items into an oset. returns the SET.
  129. (declaim (inline oset-insert-list!))
  130. (defun oset-insert-list! (list oset)
  131.   (dolist (x list oset) (oset-insert! x oset)))
  132.  
  133. ;;; It's easy to define a generic order function on osets if they
  134. ;;; have the same order function
  135. ;;; making for easy osets of osets.
  136.  
  137. (defun oset-order-function (oset-a oset-b &aux (odf (oset-order-fn oset-a)))
  138.   (declare (type oset oset-a oset-b))
  139.   (labels ((oset-order-aux (ilista ilistb)
  140.          (if (null ilista)
  141.          'equal
  142.            (let ((item-order (funcall odf (car ilista) (car ilistb))))
  143.          (if (eq 'equal item-order)
  144.              (oset-order-aux (cdr ilista) (cdr ilistb))
  145.            item-order)))))
  146.     (if (eq odf (oset-order-fn oset-b))
  147.     (let ((a-card (oset-cardinality oset-a))
  148.           (b-card (oset-cardinality oset-b)))
  149.       (declare (fixnum a-card b-card))
  150.       (if (< a-card b-card)
  151.           'correct-order
  152.         (if (= a-card b-card)
  153.         ;; same cardinality, same type, so march down the lists...
  154.         (oset-order-aux (oset-item-list oset-a)
  155.                 (oset-item-list oset-b))
  156.           'wrong-order)))
  157.       (error "incompatible types of sets: oset-order-function"))))
  158.  
  159. ; (declaim (inline oset-comparable?))
  160. ; (defun oset-comparable? (oseta osetb)
  161. ;        (eq 'equal (oset-order-function oseta osetb)))
  162.  
  163. ;----------------------------------------------------------------------------;
  164. ; oset-select-subsets
  165. ;--------------------
  166. ;;; Yields a list of disjoint subsets whose union is the set.  For
  167. ;;; each subset the value of selection-fn applied to the members is
  168. ;;; the same in the sense of eqv.
  169. ;;; partition set according to selection-fn
  170.  
  171. (defun oset-select-subsets (set selection-fn)
  172.   (let ((r-ilist (oset-item-list set))
  173.     (alist   '())
  174.     (odf     (oset-order-fn set)))
  175.     (dolist (item r-ilist)
  176.       (let* ((key (funcall selection-fn item))
  177.          (found-association (assoc key alist :test #'eql)))
  178.     (if found-association 
  179.         (setf (cdr found-association)
  180.           (cons item (cdr found-association)))
  181.       (push (cons key (list item)) alist))))
  182.     (do ((alist-tl alist (cdr alist-tl)))
  183.     ((null alist-tl) alist)
  184.       (let ((items (cdar (the cons alist-tl))))
  185.     (setf (car alist-tl) (make-oset :item-list (nreverse items)
  186.                     :cardinality (length items)
  187.                     :order-fn odf))))))
  188.  
  189. (declaim (inline oset-for-each oset-memq oset-copy oset-union oset-empty!))
  190. (defun oset-for-each (procedure set)
  191.   (declare (type oset set))
  192.   (dolist (x (oset-item-list set)) (funcall procedure x)))
  193.  
  194. (defun oset-memq (elt set)
  195.   (member elt (oset-item-list (the oset set))))
  196.  
  197. (defun oset-copy (oset)
  198.   (declare (type oset oset))
  199.   (make-oset
  200.    :item-list (copy-list (oset-item-list oset))
  201.    :order-fn (oset-order-fn oset)
  202.    :cardinality (oset-cardinality oset)))
  203.  
  204. (defun oset-union (oset1 oset2)
  205.   (declare (type oset oset1 oset2))
  206.   #||
  207.   (assert (eql (oset-order-fn oset1) (oset-order-fn oset2))
  208.       ()
  209.       "Mismatched order functions in oset union.")
  210.   (if (> (oset-cardinality oset1) (oset-cardinality oset2))
  211.       (oset-insert-list! (oset-item-list oset2)
  212.              (oset-copy oset1))
  213.     (oset-insert-list! (oset-item-list oset1)
  214.                (oset-copy oset2)))
  215.   ||#
  216.   (oset-insert-list! (oset-item-list oset1)
  217.              (oset-copy oset2)))
  218.         
  219. (defun oset-delete (item oset)
  220.   (declare (type oset oset))
  221.   (let ((item-list (oset-item-list oset)))
  222.     (if (member item item-list)
  223.     (make-oset :item-list (delete item item-list)
  224.            :cardinality (1- (oset-cardinality oset))
  225.            :order-fn (oset-order-fn oset))
  226.       oset)))            
  227.  
  228. (defun oset-empty! (oset)
  229.   (declare (type oset oset))
  230.   (setf (oset-cardinality oset) 0
  231.     (oset-item-list oset) '()))
  232.  
  233. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  234. ;;                                 LR(1) items
  235. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  236. ;;; lr(1) items.
  237. ;;; These are going to be represented by structs:
  238. ;;; after-dot is an integer which indexes the symbol in the
  239. ;;; production which follows the dot
  240. ;;; that comes after the dot.
  241. ;;;
  242. ;;; look-aheads is an oset of grammar symbols.
  243. ;;; The item data structure
  244. ;;; essentially stands for the set of lr(1) items which are the same
  245. ;;; except for each having one lookahead symbol from the set look-aheads.
  246. ;;;
  247. ;;; look-ahead-dependers is an oset of items to whom
  248. ;;; lalr(1) lookaheads
  249. ;;; propagate from this item.
  250.  
  251. (defstruct (item (:print-function item-print))
  252.   (production    nil)
  253.   (after-dot     0 :type fixnum)
  254.   (look-aheads   (make-oset :order-fn #'g-symbol-order-function))
  255.   (look-ahead-dependers
  256.                  (make-oset :order-fn #'item-order-function)))
  257.  
  258. ;;; A handy predicate.
  259. (declaim (inline dot-at-right-end?))
  260.  
  261. (defun dot-at-right-end? (item)
  262.   (declare (type item item))
  263.   (= (the fixnum (production-length (item-production item)))
  264.      (the fixnum (item-after-dot item))))
  265.  
  266. ;;; Get the symbol after the dot -- 'the-bogus-symbol if dot is flushright.
  267. (defun symbol-after-dot (item)
  268.   (declare (type item item))
  269.   (let ((pr-after (nthcdr (the fixnum (item-after-dot item))
  270.               (the list (rhs (item-production item))))))
  271.     (if pr-after
  272.     (car pr-after)
  273.       'the-bogus-symbol)))
  274.  
  275. ;;; Make an item with the dot moved one to the right, or false if
  276. ;;; dot gets past the end.
  277. ;;; Since this is used during lr(0) set construction, it only
  278. ;;; deals with production and after-dot slots, the others
  279. ;;; are filled in as '() by default.
  280. (defun advance-dot (item)
  281.   (declare (type item item))
  282.   (let ((production (item-production item))
  283.     (item-after-dot (item-after-dot item)))
  284.     (if (= (production-length production)
  285.        (the fixnum item-after-dot)) 
  286.     nil
  287.       (make-item :production production
  288.          :after-dot (1+ item-after-dot)))))
  289.  
  290. ;;; Make an item which has the dot at the left end of the rhs.
  291. (declaim (inline new-item))
  292. (defun new-item (production)
  293.   (make-item :production production))
  294.  
  295. ;;; For osets of items:
  296. ;;; this is used during lr(0) sets of items construction.  Only the
  297. ;;; production and after dot fields are tested, since these characterize
  298. ;;; lr(0) items.
  299.  
  300. (defun item-order-function (ia ib)
  301.   (declare (type item ia ib))
  302.   (let ((production-index-a (production-index (item-production ia)))
  303.     (production-index-b (production-index (item-production ib))))
  304.     (declare (fixnum production-index-a production-index-b))
  305.     (if (< production-index-a production-index-b)
  306.     'correct-order
  307.       (if (= production-index-a production-index-b)
  308.       (let ((iad (item-after-dot ia)) (ibd (item-after-dot ib)))
  309.         (declare (fixnum iad ibd))
  310.         (if (< iad ibd)
  311.         'correct-order
  312.           (if (= iad ibd)
  313.           'equal
  314.         'wrong-order)))
  315.     'wrong-order))))
  316.  
  317. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  318. ;;; test:
  319.  
  320. #||
  321.  (integer-order-function 1 2)
  322.  (setq fred (make-oset))
  323.  (oset-item-list fred)
  324.  (oset-insert! 3 fred)
  325.  (oset-insert-2! 4 fred) 
  326.  (oset-insert-list! '(5 6 7 7) fred)
  327.  (oset-insert-list! '(10 11) fred)
  328.  (oset-insert! 1100 fred)
  329.  (setq ned (make-oset))
  330.  (setq mary (make-oset :order-fn #'oset-order-function))
  331.  (oset-insert! ned mary)
  332.  (oset-insert! ned mary)
  333.  (oset-insert! fred mary)
  334.  (oset-insert! fred mary)
  335.  (mapc #'oset-item-list (oset-item-list mary))
  336.  (mapc #'oset-item-list  (oset-select-subsets fred #'(lambda (x) (> x 5))))
  337.  (mapc #'oset-item-list  (oset-select-subsets fred #'evenp))
  338.  (oset-for-each #'(lambda (x) (format t "~S " x)) fred)
  339.  (oset-memq 5 fred)
  340.  (oset-memq 99 fred)
  341.  (setq freddy (oset-copy fred))
  342.  (oset-item-list freddy)
  343.  (setq al (car (oset-select-subsets fred #'evenp)))
  344.  (setq hal (cadr (oset-select-subsets fred #'evenp)))
  345.  (oset-item-list (oset-union al hal))
  346.  (oset-item-list fred)
  347.  (oset-item-list (oset-delete 1100 fred))
  348.  (oset-empty! freddy)
  349.  (oset-item-list freddy)
  350.  
  351. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  352. ;;; test: "zebu-item"
  353. #||
  354.  (defun red ((new-item (car *productions*)))
  355.  (item-print fred)
  356.  (defvar ned (advance-dot fred))
  357.  (item-print ned)
  358.  (item-order-function ned ned)
  359.  (item-order-function ned fred)
  360.  (item-order-function fred ned)
  361.  (symbol-after-dot fred)
  362.  (dot-at-right-end? fred)
  363.  (dot-at-right-end? ned))
  364. ||#
  365.  
  366. ||#
  367. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  368. ;;                                End of zebu-oset.l
  369. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  370.